home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Dylan Related / Marlais / Marlais 0.5.9-portable sources / error.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  11.3 KB  |  478 lines  |  [TEXT/ttxt]
  1. /*
  2.  
  3.    error.c
  4.  
  5.    This software is free software; you can redistribute it and/or
  6.    modify it under the terms of the GNU Library General Public
  7.    License as published by the Free Software Foundation; either
  8.    version 2 of the License, or (at your option) any later version.
  9.  
  10.    This software is distributed in the hope that it will be useful,
  11.    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13.    Library General Public License for more details.
  14.  
  15.    You should have received a copy of the GNU Library General Public
  16.    License along with this software; if not, write to the Free
  17.    Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.    Original copyright notice follows:
  20.  
  21.    Copyright, 1993, Brent Benson.  All Rights Reserved.
  22.    0.4 & 0.5 Revisions Copyright 1994, Joseph N. Wilson.  All Rights Reserved.
  23.  
  24.    Permission to use, copy, and modify this software and its
  25.    documentation is hereby granted only under the following terms and
  26.    conditions.  Both the above copyright notice and this permission
  27.    notice must appear in all copies of the software, derivative works
  28.    or modified version, and both notices must appear in supporting
  29.    documentation.  Users of this software agree to the terms and
  30.    conditions set forth in this notice.
  31.  
  32.  */
  33.  
  34.  
  35. #include <stdio.h>
  36. #include <signal.h>
  37.  
  38. #include "error.h"
  39.  
  40. #include "alloc.h"
  41. #include "apply.h"
  42. #include "bytestring.h"
  43. #include "class.h"
  44. #include "env.h"
  45. #include "eval.h"
  46. #include "list.h"
  47. #include "parse.h"
  48. #include "prim.h"
  49. #include "print.h"
  50. #include "read.h"
  51. #include "yystype.h"
  52.  
  53. #define NUMSIGNALS 32
  54. #define IGNORE  0
  55. #define ERROR   1
  56. #define DEFAULT 2
  57.  
  58. #if (!defined __NetBSD__) && (!defined __linux__) && (!defined _HP_UX)
  59. extern char *sys_siglist[];
  60.  
  61. #else
  62. #if (defined _HP_UX)
  63. char *sys_siglist[32] =
  64. {"",
  65.  "hangup",
  66.  "interrupt",
  67.  "quit",
  68.  "illegal instruction (not reset when caught)",
  69.  "trace trap (not reset when caught)",
  70.  "IOT instruction",
  71.  "EMT instruction",
  72.  "floating point exception",
  73.  "kill (cannot be caught or ignored)",
  74.  "bus error",
  75.  "segmentation violation",
  76.  "bad argument to system call",
  77.  "write on a pipe with no one to read it",
  78.  "alarm clock",
  79.  "software termination signal from kill",
  80.  "urgent condition on IO channel",
  81.  "sendable stop signal not from tty",
  82.  "stop signal from tty",
  83.  "continue a stopped process",
  84.  "to parent on child stop or exit",
  85.  "to readers pgrp upon background tty read",
  86.  "like TTIN for output if (tp->t_local<OSTOP)",
  87.  "input/output possible signal",
  88.  "exceeded CPU time limit",
  89.  "exceeded file size limit",
  90.  "virtual time alarm",
  91.  "profiling time alarm",
  92.  "window changed",
  93.  "resource lost (eg, record-lock lost)",
  94.  "user defined signal 1",
  95.  "user defined signal 2",
  96. };
  97.  
  98. #endif
  99. #endif
  100. extern Object signal_symbol;
  101. extern Object simple_error_class;
  102.  
  103. extern int classic_syntax;
  104.  
  105.  
  106. int signal_response[32] =
  107. {IGNORE,
  108.  ERROR,                /* hangup */
  109.  DEFAULT,            /* interrupt */
  110.  DEFAULT,            /* quit */
  111.  DEFAULT,            /* illegal instruction (not reset when caught) */
  112.  DEFAULT,            /* trace trap (not reset when caught) */
  113.  DEFAULT,            /* IOT instruction */
  114.  DEFAULT,            /* EMT instruction */
  115.  ERROR,                /* floating point exception */
  116.  IGNORE,            /* kill (cannot be caught or ignored) */
  117.  DEFAULT,            /* bus error */
  118.  DEFAULT,            /* segmentation violation */
  119.  DEFAULT,            /* bad argument to system call */
  120.  ERROR,                /* write on a pipe with no one to read it */
  121.  IGNORE,            /* alarm clock */
  122.  ERROR,                /* software termination signal from kill */
  123.  DEFAULT,            /* urgent condition on IO channel */
  124.  DEFAULT,            /* sendable stop signal not from tty */
  125.  DEFAULT,            /* stop signal from tty */
  126.  DEFAULT,            /* continue a stopped process */
  127.  DEFAULT,            /* to parent on child stop or exit */
  128.  DEFAULT,            /* to readers pgrp upon background tty read */
  129.  DEFAULT,            /* like TTIN for output if (tp->t_local<OSTOP) */
  130.  ERROR,                /* input/output possible signal */
  131.  ERROR,                /* exceeded CPU time limit */
  132.  ERROR,                /* exceeded file size limit */
  133.  ERROR,                /* virtual time alarm */
  134.  ERROR,                /* profiling time alar */
  135.  ERROR,                /* window changed */
  136.  DEFAULT,            /* resource lost (eg, record-lock lost) */
  137.  ERROR,                /* user defined signal 1 */
  138.  ERROR                /* user defined signal 2 */
  139. };
  140.  
  141. struct jmp_buf_stack {
  142.     jmp_buf buf;
  143.     struct jmp_buf_stack *next;
  144. };
  145.  
  146. struct jmp_buf_stack *error_ok_return = 0;
  147.  
  148. static jmp_buf *error_ok_return_pop (void);
  149. static jmp_buf *error_ok_return_push (void);
  150. int num_debug_contexts;
  151. int NoDebug;
  152.  
  153. static void signal_handler (int sig);
  154. static Object my_print_env (void);
  155.  
  156. /* primitives */
  157.  
  158. static void signal_handler_init (void);
  159.  
  160. Object print_env_symbol;
  161. Object print_stack_symbol;
  162. Object show_bindings_symbol;
  163. Object help_symbol;
  164. Object return_symbol;
  165. Object fail_symbol;
  166. Object debugger_symbol;
  167.  
  168. static Object return_value (Object args);
  169. static Object fail_function (void);
  170. static Object help_function (void);
  171.  
  172. static Object dylan_error (Object msg_str, Object rest);
  173. static Object dylan_warning (Object msg_str, Object rest);
  174. static Object signal_error_jump ();
  175. static Object enter_debugger (void);
  176.  
  177. static struct primitive error_prims[] =
  178. {
  179.     {"%error", prim_1_rest, dylan_error},
  180.     {"%warning", prim_1_rest, dylan_warning},
  181.     {"%signal-error-jump", prim_0, signal_error_jump},
  182.     {"%debugger", prim_0, enter_debugger},
  183. };
  184.  
  185. /* function definitions */
  186.  
  187. void
  188. init_error_prims (void)
  189. {
  190.     int num;
  191.  
  192.  
  193.     print_env_symbol = make_symbol ("print-env");
  194.     print_stack_symbol = make_symbol ("print-stack");
  195.     show_bindings_symbol = make_symbol ("show-bindings");
  196.     help_symbol = make_symbol ("help");
  197.     return_symbol = make_symbol ("return");
  198.     fail_symbol = make_symbol ("fail");
  199.     debugger_symbol = make_symbol ("<<Debugger>>");
  200.  
  201.     num = sizeof (error_prims) / sizeof (struct primitive);
  202.  
  203.     init_prims (num, error_prims);
  204.     signal_handler_init ();
  205. }
  206.  
  207. static void
  208. signal_handler_init ()
  209. {
  210.     int i;
  211.  
  212.     for (i = 0; i < NUMSIGNALS; i++) {
  213.     switch (signal_response[i]) {
  214.     case IGNORE:
  215.         signal (i, SIG_IGN);
  216.         break;
  217.     case ERROR:
  218.         signal (i, signal_handler);
  219.         break;
  220.     case DEFAULT:
  221.         ;
  222.     }
  223.     }
  224. }
  225.  
  226. static Object
  227. dylan_error (Object msg_str, Object rest)
  228. {
  229.     fprintf (stderr, "error: %s", BYTESTRVAL (msg_str));
  230.     if (!NULLP (rest)) {
  231.     fprintf (stderr, ": ");
  232.     }
  233.     while (!NULLP (rest)) {
  234.     print_object (stderr, CAR (rest), 0);
  235.     rest = CDR (rest);
  236.     if (!NULLP (rest)) {
  237.         fprintf (stderr, ", ");
  238.     }
  239.     }
  240.     fprintf (stderr, ".\n");
  241.     longjmp (error_return, 1);
  242. }
  243.  
  244. static Object
  245. dylan_warning (Object msg_str, Object rest)
  246. {
  247.     fprintf (stderr, "warning: %s", BYTESTRVAL (msg_str));
  248.     if (!NULLP (rest)) {
  249.     fprintf (stderr, ": ");
  250.     }
  251.     while (!NULLP (rest)) {
  252.     print_object (stderr, CAR (rest), 0);
  253.     rest = CDR (rest);
  254.     if (!NULLP (rest)) {
  255.         fprintf (stderr, ", ");
  256.     }
  257.     }
  258.     fprintf (stderr, ".\n");
  259. }
  260.  
  261. void
  262. fatal (char *msg)
  263. {
  264.     fprintf (stderr, "%s.\n", msg);
  265.     exit (-1);
  266. }
  267.  
  268. Object
  269. error (char *msg,...)
  270. {
  271.     va_list args;
  272.     Object obj, signal_value, ret;
  273.     jmp_buf *jmp_buf_ptr;
  274.     static message_printed = 0;
  275.  
  276.     va_start (args, msg);
  277.     fprintf (stderr, "error: %s", msg);
  278.     obj = va_arg (args, Object);
  279.  
  280.     if (obj) {
  281.     fprintf (stderr, ": ");
  282.     }
  283.     while (obj) {
  284.     print_object (stderr, obj, 0);
  285.     obj = va_arg (args, Object);
  286.  
  287.     if (obj) {
  288.         fprintf (stderr, ", ");
  289.     }
  290.     }
  291.     fprintf (stderr, ".\n");
  292.  
  293.     jmp_buf_ptr = error_ok_return_push ();
  294.     ret = (Object) setjmp (*jmp_buf_ptr);
  295.     if (!NoDebug) {
  296.     /* debugger eval loop */
  297.     if (!ret) {
  298.         char *debug_prompt = "Debug> ";
  299.  
  300.         push_scope (debugger_symbol);
  301.  
  302.         /* Put debugging functions this frame */
  303.         add_binding (print_env_symbol,
  304.              make_primitive ("print-env", prim_0, my_print_env),
  305.              1);
  306.         add_binding (print_stack_symbol,
  307.              make_primitive ("print-stack", prim_0, print_stack),
  308.              1);
  309.         add_binding (show_bindings_symbol,
  310.              make_primitive ("show-bindings",
  311.                      prim_0_rest,
  312.                      show_bindings),
  313.              1);
  314.         add_binding (help_symbol,
  315.              make_primitive ("help",
  316.                      prim_0_rest,
  317.                      help_function),
  318.              1);
  319.  
  320.         add_binding (return_symbol,
  321.                make_primitive ("return", prim_0_rest, return_value),
  322.              1);
  323.         add_binding (fail_symbol,
  324.              make_primitive ("fail", prim_0, fail_function),
  325.              1);
  326.  
  327.         if (!message_printed) {
  328.         help_function ();
  329.         message_printed = 1;
  330.         }
  331.         printf ("Debug[%d]> ", num_debug_contexts);
  332.         fflush (stdout);
  333.         yy_restart (stdin);
  334.         while ((obj = (classic_syntax ? read_object (stdin)
  335.                : parse_object (stdin, 0)))
  336.            && (obj != eof_object)) {
  337.         print_obj (eval (obj));
  338.         if (!classic_syntax) {
  339.             yy_skip_ws ();
  340.         }
  341.         if (!classic_syntax && charready (stdin)) {
  342.             continue;
  343.         }
  344.         printf ("Debug[%d]> ", num_debug_contexts);
  345.         fflush (stdout);
  346.         }
  347.         fprintf (stderr, "\n");
  348.         pop_scope ();
  349.         error_ok_return_pop ();
  350.     } else {
  351.         return ret;
  352.     }
  353.     }
  354.     signal_value = symbol_value (signal_symbol);
  355.     if (signal_value) {
  356.     apply (signal_value,
  357.            cons (make (simple_error_class, make_empty_list ()),
  358.              make_empty_list ()));
  359.     } else {
  360.     longjmp (error_return, 1);
  361.     }
  362. }
  363.  
  364. static Object
  365. signal_error_jump ()
  366. {
  367.     longjmp (error_return, 1);
  368. }
  369.  
  370. static Object
  371. enter_debugger (void)
  372. {
  373.     return error ("entering debugger", NULL);
  374. }
  375.  
  376. Object
  377. warning (char *msg,...)
  378. {
  379.     va_list args;
  380.     Object obj;
  381.  
  382.     va_start (args, msg);
  383.     fprintf (stderr, "warning: %s", msg);
  384.     obj = va_arg (args, Object);
  385.  
  386.     if (obj) {
  387.     fprintf (stderr, ": ");
  388.     }
  389.     while (obj) {
  390.     print_object (stderr, obj, 0);
  391.     obj = va_arg (args, Object);
  392.  
  393.     if (obj) {
  394.         fprintf (stderr, ", ");
  395.     }
  396.     }
  397.     fprintf (stderr, ".\n");
  398.     return unspecified_object;
  399. }
  400.  
  401. static void
  402. signal_handler (int sig)
  403. {
  404. #ifdef __SunOS_5__
  405.     error ((char *) _sys_siglist[sig], NULL);
  406. #else
  407.     error (sys_siglist[sig], NULL);
  408. #endif
  409. }
  410.  
  411. static Object
  412. return_value (Object args)
  413. {
  414.     jmp_buf *buf;
  415.  
  416.     if (list_length (args) != 1) {
  417.     fprintf (stderr, "return: Requires one argument\n");
  418.     }
  419.     pop_scope ();
  420.     pop_eval_stack ();
  421.     buf = error_ok_return_pop ();
  422.     longjmp (*buf, (int) (CAR (args)));
  423. }
  424.  
  425. static Object
  426. help_function (void)
  427. {
  428.     fprintf (stderr,
  429.          "%s\n",
  430.          "** Debugger **\n\n"
  431.          "  debugging functions:\n\n"
  432.          "    print-stack () => () // print numbered entries in the runtime stack\n"
  433.          "    print-env () => ()   // print numbered frames in static environment\n"
  434.          "    show-bindings (frame-number :: <integer>) => ()\n"
  435.     "                         // show variable bindings in specified frame\n"
  436.          "    return (value) => () // return to error context with specified value\n"
  437.          "                         // return will almost always fail at this time\n"
  438.          "    help() => ()         // print this message\n"
  439.          "    fail() => ()         // or ^D returns to the read-eval-print loop\n");
  440.     return unspecified_object;
  441. }
  442.  
  443. static jmp_buf
  444. *
  445. error_ok_return_pop (void)
  446. {
  447.     jmp_buf *ret = &(error_ok_return->buf);
  448.  
  449.     num_debug_contexts--;
  450.     error_ok_return = error_ok_return->next;
  451.     return ret;
  452. }
  453.  
  454. static jmp_buf
  455. *
  456. error_ok_return_push ()
  457. {
  458.     struct jmp_buf_stack *tmp =
  459.     (struct jmp_buf_stack *) checking_malloc (sizeof (struct jmp_buf_stack));
  460.  
  461.     num_debug_contexts++;
  462.     tmp->next = error_ok_return;
  463.     error_ok_return = tmp;
  464.     return &(error_ok_return->buf);
  465. }
  466.  
  467. static Object
  468. fail_function (void)
  469. {
  470.     longjmp (error_return, 1);
  471. }
  472.  
  473. static Object
  474. my_print_env (void)
  475. {
  476.     return print_env (the_env);
  477. }
  478.